home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MISC.SWG / 0099_General Library Routines.pas < prev    next >
Pascal/Delphi Source File  |  1994-05-26  |  21KB  |  743 lines
  1. unit MiscLib;
  2. interface
  3. uses crt,dos;
  4.  
  5. const
  6.  MaxFiles = 30;
  7.  MaxChoices = 8;
  8.  
  9. type
  10.  STRING79 = string[79];
  11.  TOGGLE_REC = record
  12.    NUM_CHOICES: integer;
  13.    STRINGS    : array [0..8] of STRING79;
  14.    LOCATIONS  : array [0..8] of integer;
  15.  end;
  16.  RESPONSE_TYPE = (NO_RESPONSE, ARROW, KEYBOARD, RETURN);
  17.  MOVEMENT = (NONE, LEFT, RIGHT, UP, DOWN);
  18.  FnameType = string[12];
  19.  FileListType = array[1..MaxFiles] of FnameType;
  20.  ScrMenuRec = record
  21.    Selection  : array[1..MaxChoices] of STRING79;
  22.    Descripts  : array[1..MaxChoices,1..3] of STRING79;
  23.  end;
  24.  ScrMenuType = object
  25.    NumChoices : integer;
  26.    Last       : integer;
  27.    Line, Col  : integer;
  28.    MenuData   : ScrMenuRec;
  29.    procedure Setup(MData: ScrMenuRec);
  30.    function  GetChoice : integer;
  31.  end;
  32.  
  33.  
  34. procedure Set_Video (ATTRIBUTE: integer);
  35. procedure Put_String (OUT_STRING: STRING79; LINE, COL, ATTRIB: integer);
  36. procedure Put_Text (OUT_STRING: STRING79; LINE, COL: integer);
  37. procedure Put_Colored_Text (OUT_STRING: STRING79;
  38.                             LINE, COL, TXTCLR, BKGCLR: integer);
  39. procedure Put_Centered_String (OUT_STRING: STRING79; LINE, ATTRIB: integer);
  40. procedure Put_Centered_Text (OUT_STRING: STRING79; LINE: integer);
  41. procedure Put_Error (OUT_STRING: STRING79; LINE, COL: integer);
  42. procedure End_Erase (LINE, COL: integer);
  43. procedure Put_Prompt (OUT_STRING: STRING79; LINE, COL: integer);
  44. procedure Get_Response (var RESPONSE    : RESPONSE_TYPE;
  45.                         var DIRECTION   : MOVEMENT;
  46.                         var KEY_RESPONSE: char);
  47. procedure Get_String (var IN_STRING: STRING79;
  48.                       LINE, COL, ATTRIB, STR_LENGTH: integer);
  49. procedure Get_Integer (var NUMBER: integer;
  50.                        LINE, COL, ATTRIB, NUM_LENGTH: integer);
  51. procedure Get_Prompted_String (var IN_STRING: STRING79;
  52.                           INATTR, STR_LENGTH: integer;
  53.                                      STRDESC: STRING79;
  54.                            DESCLINE, DESCCOL: integer;
  55.                                       PROMPT: STRING79;
  56.                                PRLINE, PRCOL: integer);
  57. procedure Put_1col_Toggle (TOGGLE: TOGGLE_REC; COL, CHOICE: integer);
  58. procedure Get_1col_Toggle (    TOGGLE: TOGGLE_REC;
  59.                                   COL: integer;
  60.                            var CHOICE: integer;
  61.                                PROMPT: STRING79;
  62.                         PRLINE, PRCOL: integer);
  63. procedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);
  64. procedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);
  65. procedure swap_fnames(var A,B: FnameType);
  66. procedure FileSort(var fname: FileListType; NumFiles: integer);
  67. function  Get_Files_Toggle (choices: FileListType;
  68.                             NumChoices,NumRows,row,col:integer): FnameType;
  69. function Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;
  70.  
  71.  
  72. {-------------------------------------------------------------------------}
  73. implementation
  74.  
  75. procedure Set_Video (ATTRIBUTE: integer);
  76. {
  77. NOTES:
  78.       The attribute code, based on bits, is as follows:
  79.           0 - normal video         1 - reverse video
  80.           2 - bold video           3 - reverse and bold
  81.           4 - blinking video       5 - reverse and blinking
  82.           6 - bold and blinking    7 - reverse, bold, and blinking
  83. }
  84.  
  85. var
  86.    BLINKING,
  87.    BOLD: integer;
  88.  
  89. begin
  90.    BLINKING := (ATTRIBUTE AND 4)*4;
  91.    if (ATTRIBUTE AND 1) = 1 then
  92.       begin
  93.          BOLD := (ATTRIBUTE AND 2)*7;
  94.          Textcolor (1 + BLINKING + BOLD);
  95.          TextBackground (3);
  96.       end
  97.    else
  98.       begin
  99.          BOLD := (ATTRIBUTE AND 2)*5 DIV 2;
  100.          Textcolor (7 + BLINKING + BOLD);
  101.          TextBackground (0);
  102.       end;
  103. end;
  104.  
  105. {-------------------------------------------------------------------------}
  106.  
  107. procedure Put_String (OUT_STRING: STRING79;
  108.                      LINE, COL, ATTRIB: integer);
  109.  
  110. begin
  111.    Set_Video (ATTRIB);
  112.    GotoXY (COL, LINE);
  113.    write (OUT_STRING);
  114.    Set_Video (0);
  115. end;
  116.  
  117. {-------------------------------------------------------------------------}
  118.  
  119. procedure Put_Text (OUT_STRING: STRING79;
  120.                    LINE, COL: integer);
  121.  
  122. begin
  123.    GotoXY (COL, LINE);
  124.    write (OUT_STRING);
  125. end;
  126.  
  127. {-------------------------------------------------------------------------}
  128.  
  129. procedure Put_Colored_Text (OUT_STRING: STRING79;
  130.                            LINE, COL, TXTCLR, BKGCLR: integer);
  131.  
  132. begin
  133.    GotoXY (COL, LINE);
  134.    TextColor (TXTCLR);
  135.    TextBackground (BKGCLR);
  136.    write (OUT_STRING);
  137. end;
  138.  
  139. {-------------------------------------------------------------------------}
  140.  
  141. procedure Put_Centered_String (OUT_STRING: STRING79;
  142.                               LINE, ATTRIB: integer);
  143.  
  144. begin
  145.    Put_String (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2, ATTRIB);
  146. end;
  147.  
  148. {-------------------------------------------------------------------------}
  149.  
  150. procedure Put_Centered_Text (OUT_STRING: STRING79;
  151.                             LINE: integer);
  152.  
  153. begin
  154.    Put_Text (OUT_STRING, LINE, 40-Length(OUT_STRING) div 2);
  155. end;
  156.  
  157. {-------------------------------------------------------------------------}
  158.  
  159. procedure Put_Error (OUT_STRING: STRING79;
  160.                      LINE, COL: integer);
  161.  
  162. var
  163.    ANY_CHAR : char;
  164.  
  165. begin
  166. repeat
  167.    Put_String (OUT_STRING, LINE, COL, 6);
  168. until keypressed = true;
  169. end;
  170.  
  171. {-------------------------------------------------------------------------}
  172.  
  173. procedure End_Erase (LINE, COL: integer);
  174.  
  175. begin
  176.    GotoXY (COL, LINE);
  177.    ClrEol;
  178. end;
  179.  
  180. {-------------------------------------------------------------------------}
  181.  
  182. procedure Put_Prompt (OUT_STRING: STRING79;
  183.                      LINE, COL: integer);
  184.  
  185. begin
  186.    GotoXY (COL, LINE);
  187.    ClrEol;
  188.    Put_String (OUT_STRING, LINE, COL, 3);
  189. end;
  190.  
  191. {-------------------------------------------------------------------------}
  192.  
  193.  
  194. procedure Get_Response (var RESPONSE    : RESPONSE_TYPE;
  195.                         var DIRECTION   : MOVEMENT;
  196.                         var KEY_RESPONSE: char);
  197.  
  198. const
  199.    BELL            = 7;
  200.    CARRIAGE_RETURN = 13;
  201.    ESCAPE          = 27;
  202.    RIGHT_ARROW     = 77;
  203.    LEFT_ARROW      = 75;
  204.    DOWN_ARROW      = 80;
  205.    UP_ARROW        = 72;
  206.  
  207. var
  208.    IN_CHAR: char;
  209.  
  210. begin
  211.    RESPONSE := NO_RESPONSE;
  212.    DIRECTION := NONE;
  213.    KEY_RESPONSE := ' ';
  214.    repeat
  215.       IN_CHAR := ReadKey;
  216.       if IN_CHAR = #0 then
  217.       begin
  218.          RESPONSE := ARROW;
  219.          IN_CHAR := ReadKey;
  220.          if Ord(IN_CHAR) = LEFT_ARROW then
  221.             DIRECTION := LEFT
  222.          else if Ord(IN_CHAR) = RIGHT_ARROW then
  223.             DIRECTION := RIGHT
  224.          else if Ord(IN_CHAR) = DOWN_ARROW then
  225.             DIRECTION := DOWN
  226.          else if Ord(IN_CHAR) = UP_ARROW then
  227.             DIRECTION := UP
  228.          else
  229.          begin
  230.             RESPONSE := NO_RESPONSE;
  231.             write (Chr(BELL));
  232.          end
  233.       end
  234.       else if Ord(IN_CHAR) = CARRIAGE_RETURN then
  235.          RESPONSE := RETURN
  236.       else
  237.       begin
  238.          RESPONSE := KEYBOARD;
  239.          KEY_RESPONSE := UpCase (IN_CHAR);
  240.       end;
  241.    until RESPONSE <> NO_RESPONSE;
  242. end;
  243.  
  244. {-------------------------------------------------------------------------}
  245.  
  246. procedure Get_String (var IN_STRING: STRING79;
  247.                      LINE, COL, ATTRIB, STR_LENGTH: integer);
  248.  
  249. var
  250.    OLDSTR : STRING79;
  251.    IN_CHAR: char;
  252.    I      : integer;
  253.  
  254. const
  255.    BELL            = 7;
  256.    BACK_SPACE      = 8;
  257.    CARRIAGE_RETURN = 13;
  258.    ESCAPE          = 27;
  259.    RIGHT_ARROW     = 77;
  260.  
  261. begin
  262.    OLDSTR := IN_STRING;
  263.    Put_String (IN_STRING, LINE, COL, ATTRIB);
  264.    for I := Length(IN_STRING) to STR_LENGTH-1 do
  265.       Put_String (' ', LINE, COL + I, ATTRIB);
  266.    GotoXY (COL, LINE);
  267.    IN_CHAR := ReadKey;
  268.    if Ord(IN_CHAR) <> CARRIAGE_RETURN then
  269.       IN_STRING := '';
  270.    while Ord(IN_CHAR) <> CARRIAGE_RETURN do
  271.    begin
  272.       if Ord(IN_CHAR) = BACK_SPACE then
  273.       begin
  274.          if Length(IN_STRING) > 0 then
  275.          begin
  276.             IN_STRING[0] := Chr(Length(IN_STRING)-1);
  277.             write (Chr(BACK_SPACE));
  278.             write (' ');
  279.             write (Chr(BACK_SPACE));
  280.          end;
  281.       end  { if BACK_SPACE }
  282.       else if IN_CHAR = #0 then
  283.       begin
  284.          IN_CHAR := ReadKey;
  285.          if Ord(IN_CHAR) = RIGHT_ARROW then
  286.          begin
  287.             if Length(OLDSTR) > Length(IN_STRING) then
  288.             begin
  289.                IN_STRING[0] := Chr(Length(IN_STRING) + 1);
  290.                IN_CHAR := OLDSTR[Ord(IN_STRING[0])];
  291.                IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;
  292.                write (IN_CHAR);
  293.             end
  294.          end      { RIGHT_ARROW }
  295.             else
  296.                write (Chr(BELL));
  297.       end   { IN_CHAR = #0 }
  298.    else if Length (IN_STRING) < STR_LENGTH then
  299.       begin
  300.          IN_STRING[0] := Chr(Length(IN_STRING) + 1);
  301.          IN_STRING[Ord(IN_STRING[0])] := IN_CHAR;
  302.          TextColor (15);
  303.          TextBackGround (11);
  304.          write (IN_CHAR);
  305.       end
  306.       else
  307.          write (Chr(BELL));
  308.       IN_CHAR := ReadKey;
  309.    end;
  310.    Put_String (IN_STRING, LINE, COL, ATTRIB);
  311.    for I := Length(IN_STRING) to STR_LENGTH - 1 do
  312.       Put_String (' ', LINE, COL+I, ATTRIB);
  313. end;
  314.  
  315. {-------------------------------------------------------------------------}
  316.  
  317. procedure Get_Integer (var NUMBER: integer;
  318.                       LINE, COL, ATTRIB, NUM_LENGTH: integer);
  319.  
  320. const
  321.    BELL = 7;
  322.  
  323. var
  324.    VALCODE      : integer;
  325.    ORIGINAL_STR,
  326.    TEMP_STR     : STRING79;
  327.    TEMP_INT     : integer;
  328.  
  329. begin
  330.    Str (NUMBER:NUM_LENGTH, ORIGINAL_STR);
  331.    repeat
  332.       TEMP_STR := ORIGINAL_STR;
  333.       Get_String (TEMP_STR, LINE, COL, ATTRIB, NUM_LENGTH);
  334.       while TEMP_STR[1] = ' ' do
  335.          TEMP_STR := Copy (TEMP_STR, 2, Length (TEMP_STR));
  336.       Val (TEMP_STR, TEMP_INT, VALCODE);
  337.       if (VALCODE <> 0) then
  338.          write (Chr(BELL));
  339.    until VALCODE = 0;
  340.    NUMBER := TEMP_INT;
  341.    Str (NUMBER:NUM_LENGTH, TEMP_STR);
  342.    Put_String (TEMP_STR, LINE, COL, ATTRIB);
  343. end;
  344.  
  345. {-------------------------------------------------------------------------}
  346.  
  347. procedure Get_Prompted_String (var IN_STRING: STRING79;
  348.                           INATTR, STR_LENGTH: integer;
  349.                                      STRDESC: STRING79;
  350.                            DESCLINE, DESCCOL: integer;
  351.                                       PROMPT: STRING79;
  352.                                PRLINE, PRCOL: integer);
  353.  
  354. begin
  355.    Put_String (STRDESC, DESCLINE, DESCCOL, 2);
  356.    Put_Prompt (PROMPT, PRLINE, PRCOL);
  357.    Get_String (IN_STRING, DESCLINE, DESCCOL + Length(STRDESC),
  358.                INATTR, STR_LENGTH);
  359.    Put_String (STRDESC, DESCLINE, DESCCOL, 0);
  360. end;
  361.  
  362. {-------------------------------------------------------------------------}
  363.  
  364. procedure Put_1col_Toggle (TOGGLE: TOGGLE_REC;
  365.                            COL, CHOICE: integer);
  366.  
  367. var
  368.    I: integer;
  369.  
  370. begin
  371.    with TOGGLE do
  372.    begin
  373.       Put_String (STRINGS[0], LOCATIONS[0], COL, 0);
  374.       for I := 1 to NUM_CHOICES do
  375.          Put_String (STRINGS[I], LOCATIONS[I], COL, 0);
  376.       if (CHOICE <1) or (CHOICE > NUM_CHOICES) then
  377.          CHOICE := 1;
  378.       Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
  379.    end;
  380. end;
  381.  
  382. {-------------------------------------------------------------------------}
  383.  
  384. procedure Get_1col_Toggle (    TOGGLE: TOGGLE_REC;
  385.                                   COL: integer;
  386.                            var CHOICE: integer;
  387.                                PROMPT: STRING79;
  388.                         PRLINE, PRCOL: integer);
  389.  
  390. var
  391.    RESP : RESPONSE_TYPE;
  392.    DIR  : MOVEMENT;
  393.    KEYCH: char;
  394.  
  395. begin
  396.    Put_Colored_Text (PROMPT, PRLINE, PRCOL, 15, 0);
  397.    with TOGGLE do
  398.    begin
  399.       Put_String (STRINGS[0], LOCATIONS[0], COL, 2);
  400.       if (CHOICE < 1) or (CHOICE > NUM_CHOICES) then
  401.          CHOICE := 1;
  402.       Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
  403.       RESP := NO_RESPONSE;
  404.       while RESP <> RETURN do
  405.       begin
  406.          Get_Response (RESP, DIR, KEYCH);
  407.          case RESP of
  408.             ARROW:
  409.                if DIR = UP then
  410.                begin
  411.                   Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);
  412.                   if CHOICE = 1 then
  413.                      CHOICE := NUM_CHOICES
  414.                   else
  415.                      CHOICE := CHOICE - 1;
  416.                   Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
  417.                end
  418.                else if DIR = DOWN then
  419.                begin
  420.                   Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 0);
  421.                   if CHOICE = NUM_CHOICES then
  422.                      CHOICE := 1
  423.                   else
  424.                      CHOICE := CHOICE + 1;
  425.                   Put_String (STRINGS[CHOICE], LOCATIONS[CHOICE], COL, 1);
  426.                end
  427.             else
  428.                write (Chr(7));
  429.             KEYBOARD:  write (Chr(7));
  430.             RETURN: ;
  431.          end;
  432.       end; {while}
  433.    Put_String (STRINGS[0], LOCATIONS[0], COL, 0);
  434.    end;
  435. end;
  436.  
  437. {-------------------------------------------------------------------------}
  438.  
  439. procedure Box_Text (TopX, TopY, BotX, BotY, BoxColor: integer);
  440.  
  441. var
  442.    i     : integer;
  443.    width : integer;
  444.    height: integer;
  445.  
  446. begin
  447.    TextBackGround (BoxColor);
  448.    height := BotY - TopY;
  449.    width := BotX - TopX;
  450.    GotoXY (TopX, TopY);
  451.    for i := 1 to width do
  452.       write (' ');
  453.    for i := TopY to (TopY+height) do
  454.       begin
  455.          GotoXY (TopX, i);
  456.          write ('  ');
  457.          GotoXY (BotX-1, i);
  458.          write ('  ');
  459.       end;
  460.    GotoXY (TopX, BotY);
  461.    for i := 1 to width do
  462.       write (' ');
  463. end;
  464.  
  465. {-------------------------------------------------------------------------}
  466.  
  467. procedure Solid_Box (TopX, TopY, BotX, BotY, BoxColor: integer);
  468.  
  469. var
  470.    i     : integer;
  471.    j     : integer;
  472.    width : integer;
  473.  
  474. begin
  475.    TextBackGround (BoxColor);
  476.    GotoXY (TopX, TopY);
  477.    width := BotX - TopX;
  478.    for i := TopY to BotY do
  479.       begin
  480.          for j := 1 to width do
  481.             write (' ');
  482.          GotoXY (TopX, i);
  483.       end;
  484. end;
  485.  
  486. procedure swap_fnames(var A,B: FnameType);
  487. var
  488.   Temp : FnameType;
  489. begin
  490.   Temp := A;
  491.   A := B;
  492.   B := Temp;
  493. end;
  494.  
  495. procedure FileSort(var fname: FileListType;NumFiles: integer);
  496. var
  497.   i,j : integer;
  498. begin
  499.   for j := NumFiles downto 2 do
  500.     for i := 1 to j-1 do
  501.       if fname[i]>fname[j] then
  502.         swap_fnames(fname[i],fname[j]);
  503. end;
  504.  
  505. function Get_Files_Toggle (choices:FileListType;
  506.                            NumChoices,NumRows,row,col:integer): FnameType;
  507. var
  508.   i,r   : integer;
  509.   Resp  : Response_Type;
  510.   dir   : movement;
  511.   keych : char;
  512.  
  513. procedure Put_Files_Toggle (choices: FileListType; First,NumRows,row,col: integer);
  514. var
  515.   i : integer;
  516. begin
  517.   for i := 0 to NumRows-1 do
  518.     Put_string (choices[First+i],row+i,col,0);
  519. end;
  520.  
  521. procedure Padnames;
  522. var
  523.   i,p : integer;
  524. begin
  525.   for i := 1 to MaxFiles do
  526.     begin
  527.       p := 12-length(choices[i]);
  528.       while p>0 do
  529.         begin
  530.           choices[i] := choices[i]+' ';
  531.           p := p-1;
  532.         end;
  533.     end;
  534. end;
  535.  
  536. begin
  537.   Padnames;
  538.   i := 1;
  539.   r := 1;
  540.   if NumChoices < NumRows then
  541.     NumRows := NumChoices;
  542.   Put_Files_Toggle (choices,1,NumRows,row,col);
  543.   Get_Files_Toggle := choices[i];
  544.   Put_string(choices[i],row,col,1);
  545.   resp := No_Response;
  546.   while resp <> Return do
  547.     begin
  548.       Get_response (resp,dir,keych);
  549.       case resp of
  550.         ARROW: if dir=UP then
  551.                  begin
  552.                    Put_string(choices[i],row+r-1,col,0);
  553.                    if i=1 then
  554.                      begin
  555.                        i := NumChoices;
  556.                        r := NumRows;
  557.                        Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);
  558.                      end
  559.                    else if r=1 then
  560.                      begin
  561.                        i := i-1;
  562.                        Put_Files_Toggle(choices,i,NumRows,row,col);
  563.                      end
  564.                    else
  565.                      begin
  566.                        i := i-1;
  567.                        r := r-1;
  568.                      end;
  569.                    Put_string(choices[i],row+r-1,col,1);
  570.                  end
  571.                else if dir=DOWN then
  572.                  begin
  573.                    Put_string(choices[i],row+r-1,col,0);
  574.                    if i=NumChoices then
  575.                      begin
  576.                        i := 1;
  577.                        r := 1;
  578.                        Put_Files_Toggle(choices,i,NumRows,row,col);
  579.                      end
  580.                    else if r=NumRows then
  581.                      begin
  582.                        i := i+1;
  583.                        Put_Files_Toggle(choices,i+1-NumRows,NumRows,row,col);
  584.                      end
  585.                    else
  586.                      begin
  587.                        i := i+1;
  588.                        r := r+1;
  589.                      end;
  590.                    Put_string(choices[i],row+r-1,col,1);
  591.                  end
  592.                else
  593.                  write (chr(7));
  594.         KEYBOARD:  write (chr(7));
  595.         end; { case }
  596.     end;
  597.   Get_Files_toggle := choices[i];
  598. end;
  599.  
  600. function Get_File_Menu(mask: string;NumRows,Row,Col: integer): FnameType;
  601. var
  602.   i : integer;
  603.   NumFiles : integer;
  604.   FileList : FileListType;
  605.   dirinfo  : SearchRec;
  606. begin
  607.   i := 1;
  608.   FindFirst(mask,Archive,dirinfo);
  609.   while (DosError=0) AND (i<MaxFiles+1) do
  610.     begin
  611.       FileList[i] := dirinfo.name;
  612.       FindNext(dirinfo);
  613.       i := i+1;
  614.     end;
  615.   NumFiles := i-1;
  616.   FileSort(FileList,NumFiles);
  617.   Get_File_Menu := Get_Files_Toggle(FileList,NumFiles,NumRows,Row,Col);
  618. end;
  619.  
  620. procedure ScrMenuType.Setup(MData : ScrMenuRec);
  621. var i : integer;
  622. begin
  623.   with MenuData do
  624.     for i := 1 to MaxChoices do
  625.       begin
  626.         selection[i] := MData.selection[i];
  627.         Descripts[i,1] := MData.descripts[i,1];
  628.         Descripts[i,2] := MData.descripts[i,2];
  629.         Descripts[i,3] := MData.descripts[i,3];
  630.       end;
  631. end;
  632.  
  633. function ScrMenuType.GetChoice : integer;
  634. var
  635.   i : integer;
  636.   Resp  : Response_Type;
  637.   Dir   : Movement;
  638.   KeyCh : char;
  639.  
  640. procedure PutDescripts;
  641. var i : integer;
  642. begin
  643.   window(0,0,79,24);
  644.   Solid_Box(3,21,79,24,lightgray);
  645.   for i := 1 to 3 do
  646.     Put_Colored_Text(MenuData.Descripts[last,i],20+i,4,white,lightgray);
  647. end;
  648.  
  649. begin
  650. with MenuData do
  651. begin
  652.   for i := 0 to NumChoices-1 do
  653.     Put_String(Selection[i+1],Line+i,Col,0);
  654.   Put_String(Selection[Last],Line+Last-1,Col,1);
  655.   Resp := No_Response;
  656.   while Resp <> Return do
  657.     begin
  658.       PutDescripts;
  659.       Get_Response(Resp,Dir,KeyCh);
  660.       case Resp of
  661.         Arrow :
  662.           if Dir = Up then
  663.             begin
  664.               Put_String(Selection[Last],Line+Last-1,Col,0);
  665.               if Last = 1 then
  666.                 Last := NumChoices
  667.               else
  668.                 Last := Last-1;
  669.               Put_String(Selection[Last],Line+Last-1,Col,1);
  670.             end
  671.           else if Dir = Down then
  672.             begin
  673.               Put_String(Selection[Last],Line+Last-1,Col,0);
  674.               if Last = NumChoices then
  675.                 Last := 1
  676.               else
  677.                 Last := Last+1;
  678.               Put_String(Selection[Last],Line+Last-1,Col,1);
  679.             end;
  680.         end;
  681.     end;
  682. end;
  683. end;
  684. { Initialization Area }
  685. begin
  686. end.
  687.  
  688. {------------------------------------  TEST PROGRAM   ------------------- }
  689.  
  690. program testdir;
  691. { program attempts to read directory }
  692. { shows filenames as column }
  693.  
  694. uses dos,crt,miscLib;
  695.  
  696. var
  697.   Fchoice  : FnameType;
  698.   i,n      : integer;
  699.  
  700.  
  701.  
  702. { *************** MAIN PROGRAM *************** }
  703.  
  704. begin
  705.   ClrScr;
  706.   Fchoice := Get_File_Menu('*.*',8,10,30);
  707.   Put_string(Fchoice,24,1,0);
  708.   ReadLn;
  709. end.
  710.  
  711.  
  712. {------------------------------------  TEST PROGRAM   ------------------- }
  713.  
  714. program TestMenu;
  715. uses crt,MiscLib;
  716.  
  717. const
  718.   ChoiceData : ScrMenuRec =
  719.     (selection : ('Choice 1','Choice 2','Choice 3','Choice 4','','','','');
  720.      Descripts : (('This is','No 1','The First Choice'),
  721.                   ('Number 2','The Second Choice and default',''),
  722.                   ('Number 3','Last Choice, for now...','Last Line'),
  723.                   ('Number 4','An added Selection','How bout that?'),
  724.                   ('','',''),
  725.                   ('','',''),
  726.                   ('','',''),
  727.                   ('','','')));
  728. var
  729.   ScrMenu : ScrMenuType;
  730.   Choice : integer;
  731.  
  732. begin
  733.   TextColor(white);
  734.   TextBackGround(Blue);
  735.   ClrScr;
  736.   ScrMenu.NumChoices := 4;
  737.   ScrMenu.Last := 2;
  738.   ScrMenu.Line := 6;
  739.   ScrMenu.Col  := 30;
  740.   ScrMenu.Setup(ChoiceData);
  741.   Choice := ScrMenu.GetChoice;
  742.   ReadLn;
  743. end.